home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / env / flatload.scm < prev    next >
Text File  |  1995-10-13  |  3KB  |  108 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ; flatloaded -> load
  4.  
  5. (define *noisy?* #f)
  6.  
  7. (define (flatload struct . env-option)
  8.   (let ((env (if (null? env-option)
  9.          (interaction-environment)
  10.          (car env-option)))
  11.     (l '())
  12.     (set-package-loaded?! set-package-loaded?!))
  13.     (walk-packages (list struct)
  14.            (lambda (p)
  15.              (not (package-loaded? p)))
  16.            (lambda (file p)
  17.              (let* ((fn (package-file-name p))
  18.                 (file (namestring file
  19.                           (if fn
  20.                           (file-name-directory fn)
  21.                           #f)
  22.                          *load-file-type*)))
  23.                (if *noisy?*
  24.                (begin (display #\space) (display file)))
  25.                (set! l (cons (lambda () (apply fload file env-option))
  26.                      l))))
  27.            (lambda (forms p)
  28.              (set! l (cons (lambda ()
  29.                      (for-each (lambda (form)
  30.                          (eval form env))
  31.                            forms))
  32.                    l)))
  33.            (lambda (p)
  34.              (set! l (cons (lambda ()
  35.                      (set-package-loaded?! p #t))
  36.                    l))))
  37.     (for-each (lambda (thunk) (thunk)) (reverse l))
  38.     (newline)))
  39.  
  40. (define *source-file-name* "")    ;Cf. alt/config.scm
  41. (define (fload filename . rest)
  42.   (let ((save filename))
  43.     (dynamic-wind (lambda () (set! *source-file-name* filename))
  44.           (lambda ()
  45.             (apply load filename rest))
  46.           (lambda () (set! *source-file-name* save)))))
  47.  
  48. (define (walk-packages structs process? file-action forms-action after-action)
  49.   (let ((seen '()))
  50.     (letrec ((recur
  51.           (lambda (s)
  52.         (let ((p (structure-package s)))
  53.           (if (not (memq p seen))
  54.               (begin 
  55.             (set! seen (cons p seen))
  56.             (if (process? p)
  57.                 (begin
  58.                   (if *noisy?*
  59.                   (begin (newline)
  60.                      (display "[")
  61.                      (write (structure-name s))))
  62.                   ;; (write (structure-name s)) (display " ")
  63.                   (for-each recur (package-opens p))
  64.                   (for-each (lambda (name+struct)
  65.                       (recur (cdr name+struct)))
  66.                     (package-accesses p))
  67.                   (for-each (lambda (clause)
  68.                       (case (car clause)
  69.                         ((files)
  70.                          (for-each (lambda (f)
  71.                              (file-action f p))
  72.                                (cdr clause)))
  73.                         ((begin)
  74.                          (forms-action (cdr clause) p))))
  75.                     (package-clauses p))
  76.                   (after-action p)
  77.                   (if *noisy?* (display "]"))))))))))
  78.       (for-each recur structs))
  79.     (if *noisy?* (newline))
  80.     seen))
  81.  
  82.  
  83. ; Return list of names of all files needed to build a particular structure.
  84. ; This is handy for creating dependency lists for "make".
  85.  
  86. (define (all-file-names struct . base-option)
  87.   (let ((l '())
  88.     (b '()))
  89.     (walk-packages base-option
  90.            (lambda (p) #t)
  91.            (lambda (filename p) #f)
  92.            (lambda (forms p) #f)
  93.            (lambda (p)
  94.              (set! b (cons p b))))
  95.     (walk-packages (list struct)
  96.            (lambda (p)
  97.              (not (memq p b)))
  98.            (lambda (filename p)
  99.              (let ((dir (file-name-directory (package-file-name p))))
  100.                (set! l (cons (namestring filename dir *load-file-type*)
  101.                      l))))
  102.            (lambda (forms p)
  103.              (display "Package contains (begin ...) clause: ")
  104.              (write forms)
  105.              (newline))
  106.            (lambda (p) #f))
  107.     (reverse l)))
  108.